;;;; RLlib copyright 2010 Adam White (theroguemonkey@gmail.com)
;;;; Licensed under GNU General Public Licence v2 or later - refer COPYING

(in-package #:rllib)

;;;============================================================================
;;; coords
;;;============================================================================

(defun make-coords (x y)
  (cons x y))

(defun make-coords-* (list)
  (apply #'make-coords list))

(defun coords-x (c)
  (car c))

(defun coords-y (c)
  (cdr c))

(defun coords-p (c)
  (and (consp c) (integerp (car c)) (integerp (cdr c))))

(defun coords->list (c)
  (list (coords-x c) (coords-y c)))

(defun (setf coords-x) (val c)
  (rplaca c val))

(defun (setf coords-y) (val c)
  (rplacd c val))

(defun adj-coords (coords x y)
  (make-coords (+ (coords-x coords) x)
	       (+ (coords-y coords) y)))

(defun collect-coords-* (x1 y1 x2 y2)
  (loop for x from x1 below x2 nconc (loop for y from y1 below y2 collect (cons x y))))

(defun collect-coords (tl br)
  (collect-coords-* (coords-x tl) (coords-y tl) (coords-x br) (coords-y br)))

(defun collect-bounded-coords (tl br width height)
  (collect-coords-* (max 0 (coords-x tl)) (max 0 (coords-y tl))
		    (min (1- width) (coords-x br)) (min (1- height) (coords-y br))))

(defun collect-bounded-coords-* (tlx tly brx bry width height)
  (collect-coords-* (max 0 tlx) (max 0 tly) (min (1- width) brx) (min (1- height) bry)))

(defun collect-coords-square (tl size)
  (collect-coords-* (coords-x tl) (coords-y tl) (+ (coords-x tl) size) (+ (coords-y tl) size)))

;;;============================================================================
;;; queue (from ANSI Common Lisp by Paul Graham)
;;;============================================================================

(defun make-queue ()
  (cons nil nil))


(defun queue-push (obj queue)
  "Push a new OBJ onto a QUEUE"
  (if (null (car queue))
      (setf (cdr queue) (setf (car queue) (list obj)))
      (setf (cdr (cdr queue)) (list obj)
	    (cdr queue) (cdr (cdr queue)))))


(defun queue-pop (queue)
  "Return (and remove) the topmost object from QUEUE"
  (pop (car queue)))


(defun queue-top (queue)
  "Return (but not remove) the topmost object from QUEUE"
  (first (car queue)))


(defun queue-clear ()
  (make-queue))


(defun queue-empty-p (queue)
  (caar queue))

;;;============================================================================
;;; heap (priority queue)
;;;============================================================================

(defstruct (heap (:constructor
		  make-heap (&key
			     (< #'<)
			     (key #'identity)
			     (size 10) 
			     &aux
			     (count 0)
			     (elements (make-array size :adjustable t
						   :fill-pointer 0))))
		 (:conc-name %heap-))
  count elements < key)

(defun %eql-or-better (< x y)
  (or (funcall < x y) (not (funcall < y x))))

(defun heap-push (obj heap)
  "Push a new OBJ onto a HEAP"
  (declare (type heap heap))
  (with-accessors ((key %heap-key)
		   (h< %heap-<)
		   (elements %heap-elements)
		   (count %heap-count)) heap
    (if (< (fill-pointer elements)
	   (array-dimension elements 0))
	(vector-push obj elements)
	(vector-push-extend obj elements))    
    (do* ((j (1+ count))
	  (i (floor j 2) (floor j 2))
	  (obj-key (funcall key obj))
	  (done nil))
	 (done t)
      (if (or (= i 0)
	      (funcall h< (funcall key (aref elements (1- i))) obj-key))
	  (setf (aref elements (1- j)) obj
		count (1+ count)
		done t)
	  (setf (aref elements (1- j)) (aref elements (1- i))
		j i)))))


(defun heap-find (item heap &key (key #'identity) (test #'eql))
  (declare (type heap heap))
  (find item (%heap-elements heap) :key key :test test))


(defun heap-remove (item heap &key (key #'identity))
  (declare (type heap heap))
  (let ((hole (position item (%heap-elements heap) :key key)))
    
    (when hole
      (loop for j from hole below (decf (%heap-count heap))
	    do (setf (aref (%heap-elements heap) j)
		     (aref (%heap-elements heap) (1+ j))))
	 (decf (fill-pointer (%heap-elements heap)))
	 (heap-re-heapify heap)))	 
  heap)


(defun heap-re-heapify (heap) 
  (with-accessors ((key %heap-key)
		   (h< %heap-<)
		   (elems %heap-elements)
		   (count %heap-count)) heap
    (labels ((heapify (i)
	       (let* ((left (+ 1 i i))
		      (right (+ 2 i i))
		      (smallest (if (and (<= left (1- count))
					 (%eql-or-better h< 
							 (funcall key (aref elems left))
							 (funcall key (aref elems i))))
				    left
				    i)))
		 (if (and (<= right (1- count))
			  (%eql-or-better h<
					  (funcall key (aref elems right))
					  (funcall key (aref elems smallest))))
		     (setf smallest right))
		 (when (/= smallest i)
		   (rotatef (aref elems i) (aref elems smallest))
		   (heapify smallest)))))

      (loop for i from (floor count 2) downto 0
	 do (heapify i)))))
		   
		   


(defun heap-clear (heap)
  "Reset the HEAP back to nil elements"
  (declare (type heap heap))
  (setf (%heap-elements heap) (make-array (fill-pointer (%heap-elements heap))
					  :adjustable t :fill-pointer 0)
	(%heap-count heap) 0))


(defun heap-empty-p (heap)
  (declare (type heap heap))
  (zerop (%heap-elements heap)))


(defun heap-top (heap)
  "Get the topmost object from HEAP, without removing it"
  (declare (type heap heap))
  (and (plusp (%heap-count heap))
       (values (aref (%heap-elements heap) 0) t)))


(defun heap-pop (heap)
  "Remove the topmost object from HEAP, returning it"
  (declare (type heap heap))
  (multiple-value-prog1 (heap-top heap) 
    (when (plusp (%heap-count heap))
      (with-accessors ((key %heap-key) (h< %heap-<) (elements %heap-elements)
		       (count %heap-count)) heap
	(loop
	   with key-object = (setf (aref elements 0)
				   (aref elements (1- count)))
	   with key-object-key = (funcall key key-object)
	   for i = 1 then j
	   for j = 2 then (* j 2)
	   while (< j count)
	   when (and (/= j (1- count))
		     (not (%eql-or-better
			   h< (funcall key (aref elements (1- j)))
			   (funcall key (aref elements j)))))
	   do (incf j)
	   until (%eql-or-better h< key-object-key
				 (funcall key (aref elements (1- j))))
	   do (setf (aref elements (1- i)) (aref elements (1- j)))	     
	   finally
	   (setf (aref elements (1- i)) key-object
		 count (1- count)
		 (fill-pointer elements) (1- (fill-pointer elements))))))))
 

(defun heap-verify (heap)
  (declare (type heap heap))
  (with-slots (key < elements count) heap
    (dotimes (i count)
      (unless (or (>= (1+ (* i 2)) count)
		  (%eql-or-better <
				  (funcall key (aref elements i))
				  (funcall key (aref elements (1+ (* i 2))))))
	(error "Parent ~A is not better than left child ~A"
	       (funcall key (aref elements i))
	       (funcall key (aref elements (1+ (* i 2))))))
      (unless (or (>= (* (1+ i) 2) count)
		  (eql-or-better <
				 (funcall key (aref elements i))
				 (funcall key (aref elements (* (1+ i) 2)))))
	(error "Parent ~A is not better than right child ~A"
	       (funcall key (aref elements i))
	       (funcall key (aref elements (* (1+ i) 2)))))))
  t)


(defun heap-test (n)
  (let ((heap (make-heap :key #'char-code)))
    (dotimes (i n)
      (heap-push (code-char (+ 65 (random 26))) heap)
      (heap-verify heap))
    (dotimes (j n)
      (heap-pop heap)
      (heap-verify heap))
  t))


;;;============================================================================
;;; Skiplist
;;;============================================================================

;; Translated from my C++ template
;; http://roguemonkey.googlecode.com/svn/trunk/old/skiplist.h

(defstruct (skiplist-node (:constructor %make-skiplist-node)
			  (:conc-name %skln-))
  forward value)

(defun make-skiplist-node (level value)
  (%make-skiplist-node :forward (make-array level :initial-element nil) :value value))

(defstruct (skiplist (:constructor %make-skiplist)
		     (:conc-name %skl-))
  < test key header size max-size)

(defun make-skiplist (&key (< #'<) (key #'identity) (test #'eql) (size 5))
  (%make-skiplist :< < :key key :test test :max-size size :size 0 :header (make-skiplist-node size nil)))

(declaim (inline %skl-compare))
(defun %skl-compare (skiplist node value)
  (funcall (%skl-< skiplist) (funcall (%skl-key skiplist) (%skln-value node)) value))

(declaim (inline %ptr->forward[]))
(defun %ptr->forward[] (ptr i)
  (svref (%skln-forward ptr) i))

(declaim (inline (setf %ptr->forward[])))
(defun (setf %ptr->forward[]) (value ptr i)
  (setf (svref (%skln-forward ptr) i) value))

(defun skiplist-find (item skiplist)
  (with-accessors ((header %skl-header) (max-size %skl-max-size) (key %skl-key) (test %skl-test)) skiplist
    (let ((ptr header)
	(kitem (funcall key item)))
    (loop for i downfrom (1- max-size) to 0 do
	 (loop while (bwhen fptr (%ptr->forward[] ptr i) (%skl-compare skiplist fptr kitem)) do
	      (setf ptr (%ptr->forward[] ptr i))))
    (bif final (%ptr->forward[] ptr 0)
	 (when (funcall test (funcall key (%skln-value final)) kitem)
	     (%skln-value final))))))


(defun skiplist-insert (item skiplist)
  (with-accessors ((header %skl-header) (max-size %skl-max-size) (cur-size %skl-size)
		   (key %skl-key))  skiplist
    (let ((update (make-array max-size :initial-element nil))
	  (ptr header)
	  (kitem (funcall key item)))
    
      (loop for i downfrom (1- max-size) to 0 do
	   (loop while (bwhen fptr (%ptr->forward[] ptr i) (%skl-compare skiplist fptr kitem)) do
		(setf ptr (%ptr->forward[] ptr i)))
	   (setf (svref update i) ptr))

      (let* ((level (1+ (random max-size)))
	     (new (make-skiplist-node level item)))
	(when (> level cur-size)
	  (setf (svref update cur-size) header
		level (incf cur-size)))

	(loop for i below level do
	     (setf (%ptr->forward[] new i) (%ptr->forward[] (svref update i) i)
		   (%ptr->forward[] (svref update i) i) new))))))

(defun skiplist-front (skiplist)
  (bif front (%ptr->forward[] (%skl-header skiplist) 0)
       (%skln-value front)
       nil))

(defun skiplist-delete (item skiplist)
  (with-accessors ((header %skl-header) (max-size %skl-max-size) (cur-size %skl-size)
		   (key %skl-key) (test %skl-test)) skiplist
    (let ((update (make-array max-size :initial-element nil))
	  (ptr header)
	  (kitem (funcall key item)))

      (loop for i downfrom (1- max-size) to 0 do
	   (loop while (bwhen fptr (%ptr->forward[] ptr i) (%skl-compare skiplist fptr kitem)) do
		(setf ptr (%ptr->forward[] ptr i)))
	   (setf (svref update i) ptr))

      (let ((ptr (%ptr->forward[] ptr 0)))
	(when (and ptr (funcall test (funcall (%skl-key skiplist) (%skln-value ptr)) kitem))
	  (loop for i below cur-size do
	       (if (eq (%ptr->forward[] (svref update i) i) ptr)
		   (setf (%ptr->forward[] (svref update i) i) (%ptr->forward[] ptr i))
		   (return nil)))
	  (loop while (and (> cur-size 1) (not (%ptr->forward[] header (1- cur-size)))) do
	       (decf cur-size)))))))


(defun skiplist-print (skiplist)
  (do ((ptr (%ptr->forward[] (%skl-header skiplist) 0) (%ptr->forward[] ptr 0)))
      ((not ptr))
    (format t "~A "(%skln-value ptr))))


(defmethod print-object ((skiplist skiplist) stream)
  (let ((*standard-output* stream))
    (skiplist-print skiplist)))

